home *** CD-ROM | disk | FTP | other *** search
/ PD Collection CD 1 / PD Collection CD 1.iso / programer2 / lisp / xlisp / !XLisp / c / XLFIO < prev    next >
Text File  |  1990-02-23  |  7KB  |  332 lines
  1. /* xlfio.c - xlisp file i/o */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. #ifdef MEGAMAX
  9. overlay "io"
  10. #endif
  11.  
  12. /* external variables */
  13. extern NODE *s_stdin,*s_stdout,*true;
  14. extern NODE ***xlstack;
  15. extern int xlfsize;
  16. extern char buf[];
  17.  
  18. /* external routines */
  19. extern FILE *fopen();
  20.  
  21. /* forward declarations */
  22. FORWARD NODE *printit();
  23. FORWARD NODE *flatsize();
  24. FORWARD NODE *openit();
  25.  
  26. /* xread - read an expression */
  27. NODE *xread(args)
  28.   NODE *args;
  29. {
  30.     NODE ***oldstk,*fptr,*eof,*rflag,*val;
  31.  
  32.     /* create a new stack frame */
  33.     oldstk = xlsave(&fptr,&eof,(NODE **)NULL);
  34.  
  35.     /* get file pointer and eof value */
  36.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
  37.     eof = (args ? xlarg(&args) : NIL);
  38.     rflag = (args ? xlarg(&args) : NIL);
  39.     xllastarg(args);
  40.  
  41.     /* read an expression */
  42.     if (!xlread(fptr,&val,rflag != NIL))
  43.     val = eof;
  44.  
  45.     /* restore the previous stack frame */
  46.     xlstack = oldstk;
  47.  
  48.     /* return the expression */
  49.     return (val);
  50. }
  51.  
  52. /* xprint - built-in function 'print' */
  53. NODE *xprint(args)
  54.   NODE *args;
  55. {
  56.     return (printit(args,TRUE,TRUE));
  57. }
  58.  
  59. /* xprin1 - built-in function 'prin1' */
  60. NODE *xprin1(args)
  61.   NODE *args;
  62. {
  63.     return (printit(args,TRUE,FALSE));
  64. }
  65.  
  66. /* xprinc - built-in function princ */
  67. NODE *xprinc(args)
  68.   NODE *args;
  69. {
  70.     return (printit(args,FALSE,FALSE));
  71. }
  72.  
  73. /* xterpri - terminate the current print line */
  74. NODE *xterpri(args)
  75.   NODE *args;
  76. {
  77.     NODE *fptr;
  78.  
  79.     /* get file pointer */
  80.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
  81.     xllastarg(args);
  82.  
  83.     /* terminate the print line and return nil */
  84.     xlterpri(fptr);
  85.     return (NIL);
  86. }
  87.  
  88. /* printit - common print function */
  89. LOCAL NODE *printit(args,pflag,tflag)
  90.   NODE *args; int pflag,tflag;
  91. {
  92.     NODE ***oldstk,*fptr,*val;
  93.  
  94.     /* create a new stack frame */
  95.     oldstk = xlsave(&fptr,&val,(NODE **)NULL);
  96.  
  97.     /* get expression to print and file pointer */
  98.     val = xlarg(&args);
  99.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
  100.     xllastarg(args);
  101.  
  102.     /* print the value */
  103.     xlprint(fptr,val,pflag);
  104.  
  105.     /* terminate the print line if necessary */
  106.     if (tflag)
  107.     xlterpri(fptr);
  108.  
  109.     /* restore the previous stack frame */
  110.     xlstack = oldstk;
  111.  
  112.     /* return the result */
  113.     return (val);
  114. }
  115.  
  116. /* xflatsize - compute the size of a printed representation using prin1 */
  117. NODE *xflatsize(args)
  118.   NODE *args;
  119. {
  120.     return (flatsize(args,TRUE));
  121. }
  122.  
  123. /* xflatc - compute the size of a printed representation using princ */
  124. NODE *xflatc(args)
  125.   NODE *args;
  126. {
  127.     return (flatsize(args,FALSE));
  128. }
  129.  
  130. /* flatsize - compute the size of a printed expression */
  131. LOCAL NODE *flatsize(args,pflag)
  132.   NODE *args; int pflag;
  133. {
  134.     NODE ***oldstk,*val;
  135.  
  136.     /* create a new stack frame */
  137.     oldstk = xlsave(&val,(NODE **)NULL);
  138.  
  139.     /* get the expression */
  140.     val = xlarg(&args);
  141.     xllastarg(args);
  142.  
  143.     /* print the value to compute its size */
  144.     xlfsize = 0;
  145.     xlprint(NIL,val,pflag);
  146.  
  147.     /* restore the previous stack frame */
  148.     xlstack = oldstk;
  149.  
  150.     /* return the length of the expression */
  151.     return (cvfixnum((FIXNUM)xlfsize));
  152. }
  153.  
  154. /* xopeni - open an input file */
  155. NODE *xopeni(args)
  156.   NODE *args;
  157. {
  158.     return (openit(args,"r"));
  159. }
  160.  
  161. /* xopeno - open an output file */
  162. NODE *xopeno(args)
  163.   NODE *args;
  164. {
  165.     return (openit(args,"w"));
  166. }
  167.  
  168. /* openit - common file open routine */
  169. LOCAL NODE *openit(args,mode)
  170.   NODE *args; char *mode;
  171. {
  172.     NODE *fname,*val;
  173.     char *name;
  174.     FILE *fp;
  175.  
  176.     /* get the file name */
  177.     fname = xlarg(&args);
  178.     xllastarg(args);
  179.  
  180.     /* get the name string */
  181.     if (symbolp(fname))
  182.     name = getstring(getpname(fname));
  183.     else if (stringp(fname))
  184.     name = getstring(fname);
  185.     else
  186.     xlfail("bad argument type",fname);
  187.  
  188.     /* try to open the file */
  189.     if ((fp = fopen(name,mode)) != NULL)
  190.     val = cvfile(fp);
  191.     else
  192.     val = NIL;
  193.  
  194.     /* return the file pointer */
  195.     return (val);
  196. }
  197.  
  198. /* xclose - close a file */
  199. NODE *xclose(args)
  200.   NODE *args;
  201. {
  202.     NODE *fptr;
  203.  
  204.     /* get file pointer */
  205.     fptr = xlmatch(FPTR,&args);
  206.     xllastarg(args);
  207.  
  208.     /* make sure the file exists */
  209.     if (getfile(fptr) == NULL)
  210.     xlfail("file not open");
  211.  
  212.     /* close the file */
  213.     fclose(getfile(fptr));
  214.     setfile(fptr,NULL);
  215.  
  216.     /* return nil */
  217.     return (NIL);
  218. }
  219.  
  220. /* xrdchar - read a character from a file */
  221. NODE *xrdchar(args)
  222.   NODE *args;
  223. {
  224.     NODE *fptr;
  225.     int ch;
  226.  
  227.     /* get file pointer */
  228.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
  229.     xllastarg(args);
  230.  
  231.     /* get character and check for eof */
  232.     return ((ch = xlgetc(fptr)) == EOF ? NIL : cvfixnum((FIXNUM)ch));
  233. }
  234.  
  235. /* xpkchar - peek at a character from a file */
  236. NODE *xpkchar(args)
  237.   NODE *args;
  238. {
  239.     NODE *flag,*fptr;
  240.     int ch;
  241.  
  242.     /* peek flag and get file pointer */
  243.     flag = (args ? xlarg(&args) : NIL);
  244.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
  245.     xllastarg(args);
  246.  
  247.     /* skip leading white space and get a character */
  248.     if (flag)
  249.     while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
  250.         xlgetc(fptr);
  251.     else
  252.     ch = xlpeek(fptr);
  253.  
  254.     /* return the character */
  255.     return (ch == EOF ? NIL : cvfixnum((FIXNUM)ch));
  256. }
  257.  
  258. /* xwrchar - write a character to a file */
  259. NODE *xwrchar(args)
  260.   NODE *args;
  261. {
  262.     NODE *fptr,*chr;
  263.  
  264.     /* get the character and file pointer */
  265.     chr = xlmatch(INT,&args);
  266.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
  267.     xllastarg(args);
  268.  
  269.     /* put character to the file */
  270.     xlputc(fptr,(int)getfixnum(chr));
  271.  
  272.     /* return the character */
  273.     return (chr);
  274. }
  275.  
  276. /* xreadline - read a line from a file */
  277. NODE *xreadline(args)
  278.   NODE *args;
  279. {
  280.     NODE ***oldstk,*fptr,*str,*newstr;
  281.     int len,blen,ch;
  282.     char *p,*sptr;
  283.  
  284.     /* create a new stack frame */
  285.     oldstk = xlsave(&fptr,&str,(NODE **)NULL);
  286.  
  287.     /* get file pointer */
  288.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
  289.     xllastarg(args);
  290.  
  291.     /* get character and check for eof */
  292.     len = blen = 0; p = buf;
  293.     while ((ch = xlgetc(fptr)) != EOF && ch != '\n') {
  294.  
  295.     /* check for buffer overflow */
  296.     if (blen >= STRMAX) {
  297.          newstr = newstring(len+STRMAX);
  298.         sptr = getstring(newstr); *sptr = 0;
  299.         if (str) strcat(sptr,getstring(str));
  300.         *p = 0; strcat(sptr,buf);
  301.         p = buf; blen = 0;
  302.         len += STRMAX;
  303.         str = newstr;
  304.     }
  305.  
  306.     /* store the character */
  307.     *p++ = ch; blen++;
  308.     }
  309.  
  310.     /* check for end of file */
  311.     if (len == 0 && p == buf && ch == EOF) {
  312.     xlstack = oldstk;
  313.     return (NIL);
  314.     }
  315.  
  316.     /* append the last substring */
  317.     if (str == NIL || blen) {
  318.     newstr = newstring(len+blen);
  319.     sptr = getstring(newstr); *sptr = 0;
  320.     if (str) strcat(sptr,getstring(str));
  321.     *p = 0; strcat(sptr,buf);
  322.     str = newstr;
  323.     }
  324.  
  325.     /* restore the previous stack frame */
  326.     xlstack = oldstk;
  327.  
  328.     /* return the string */
  329.     return (str);
  330. }
  331.  
  332.